home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / lang / fpcsrc.lha / fpc / compiler / cobjects.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  35KB  |  1,323 lines
  1. {
  2.     $Id: cobjects.pas,v 1.1.1.1.2.4 1998/08/31 12:19:28 peter Exp $
  3.     Copyright (c) 1993-98 by Florian Klaempfl
  4.  
  5.     This module provides some basic objects
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23.  
  24. {$ifdef tp}
  25.   {$E+,N+,D+,F+}
  26. {$endif}
  27. {$I-}
  28. {$R-}{ necessary for crc calculation }
  29.  
  30. unit cobjects;
  31.  
  32.   interface
  33.  
  34.     uses
  35.        strings
  36. {$ifndef linux}
  37.        ,dos
  38. {$else}
  39.        ,dos
  40.        ,linux
  41. {$endif}
  42.       ;
  43.  
  44.     type
  45.        pstring = ^string;
  46.  
  47.        { some help data types }
  48.        pstringitem = ^tstringitem;
  49.  
  50.        tstringitem = record
  51.           data : pstring;
  52.           next : pstringitem;
  53.        end;
  54.  
  55.        plinkedlist_item = ^tlinkedlist_item;
  56.  
  57.        tlinkedlist_item = object
  58.           next,last : plinkedlist_item;
  59.           { does nothing }
  60.           constructor init;
  61.           destructor done;virtual;
  62.        end;
  63.  
  64.        pstring_item = ^tstring_item;
  65.  
  66.        tstring_item = object(tlinkedlist_item)
  67.           str : pstring;
  68.           constructor init(const s : string);
  69.           destructor done;virtual;
  70.        end;
  71.  
  72.        plinkedlist = ^tlinkedlist;
  73.  
  74.        { this implements a double linked list }
  75.        tlinkedlist = object
  76.           first,last : plinkedlist_item;
  77.           constructor init;
  78.           destructor done;
  79.  
  80.           { disposes the items of the list }
  81.           procedure clear;
  82.  
  83.           { concats a new item at the end }
  84.           procedure concat(p : plinkedlist_item);
  85.  
  86.           { inserts a new item at the begin }
  87.           procedure insert(p : plinkedlist_item);
  88.  
  89.           { inserts another list at the begin and make this list empty }
  90.           procedure insertlist(p : plinkedlist);
  91.  
  92.           { concats another list at the end and make this list empty }
  93.           procedure concatlist(p : plinkedlist);
  94.  
  95.           { removes p from the list (p isn't disposed) }
  96.           { it's not tested if p is in the list !      }
  97.           procedure remove(p : plinkedlist_item);
  98.        end;
  99.  
  100.        { String Queue}
  101.        PStringQueue=^TStringQueue;
  102.        TStringQueue=object
  103.          first,last : PStringItem;
  104.          constructor Init;
  105.          destructor Done;
  106.          function Empty:boolean;
  107.          function Get:string;
  108.          procedure Insert(const s:string);
  109.          procedure Concat(const s:string);
  110.          procedure Clear;
  111.        end;
  112.  
  113.        { string container }
  114.        pstringcontainer = ^tstringcontainer;
  115.  
  116.        tstringcontainer = object
  117.           root,last : pstringitem;
  118.  
  119.           { if this is set to true, doubles are allowed }
  120.           { true is default                             }
  121.           doubles : boolean;
  122.           constructor init;
  123.           destructor done;
  124.  
  125.           { true is the container empty }
  126.           function empty:boolean;
  127.  
  128.  
  129.           { inserts a string }
  130.           procedure insert(const s : string);
  131.  
  132.           { gets a string }
  133.           function get : string;
  134.  
  135.           { deletes all strings }
  136.           procedure clear;
  137.        end;
  138.  
  139.        pbufferedfile = ^tbufferedfile;
  140.  
  141.        { this is implemented to allow buffered binary I/O }
  142.        tbufferedfile = object
  143.            f : file;
  144.            buf : pchar;
  145.            bufsize,buflast,bufpos : longint;
  146.  
  147.            { 0 closed, 1 input, 2 output }
  148.            iomode : byte;
  149.  
  150.            { true, if the compile should change the endian of the output }
  151.            change_endian : boolean;
  152.  
  153.            { calcules a crc for the file,                                    }
  154.            { but it's assumed, that there no seek while do_crc is true       }
  155.            do_crc : boolean;
  156.            crc : longint;
  157.  
  158.            { temporary closing feature }
  159.            tempclosed : boolean;
  160.            tempmode : byte;
  161.            temppos : longint;
  162.  
  163.            { inits a buffer with the size bufsize which is assigned to }
  164.            { the file  filename                                        }
  165.            constructor init(const filename : string;_bufsize : longint);
  166.  
  167.            { closes the file, if needed, and releases the memory }
  168.            destructor done;virtual;
  169.  
  170.            { opens the file for input, other accesses are rejected }
  171.            procedure reset;
  172.  
  173.            { opens the file for output, other accesses are rejected }
  174.            procedure rewrite;
  175.  
  176.            { reads or writes the buffer from or to disk }
  177.            procedure flush;
  178.  
  179.            { temporary closing }
  180.            procedure tempclose;
  181.            procedure tempreopen;
  182.  
  183.            { writes a string to the file }
  184.            { the string is written without a length byte }
  185.            procedure write_string(const s : string);
  186.  
  187.            { writes a zero terminated string }
  188.            procedure write_pchar(p : pchar);
  189.  
  190.            { write specific data types, takes care of }
  191.            { byte order                               }
  192.            procedure write_byte(b : byte);
  193.            procedure write_word(w : word);
  194.            procedure write_long(l : longint);
  195.            procedure write_double(d : double);
  196.  
  197.            { writes any data }
  198.            procedure write_data(var data;count : longint);
  199.  
  200.            { reads any data }
  201.            procedure read_data(var data;bytes : longint;var count : longint);
  202.  
  203.            { closes the file and releases the buffer }
  204.            procedure close;
  205.  
  206. {$ifdef MAKELIB}
  207.            { used for making tiny files for libs }
  208.            procedure changename(filename : string);
  209. {$endif MAKELIB}
  210.  
  211.            { goto the given position }
  212.            procedure seek(l : longint);
  213.  
  214.            { installes an user defined buffer      }
  215.            { and releases the old one, but be      }
  216.            { careful, if the old buffer contains   }
  217.            { data, this data is lost               }
  218.            procedure setbuf(p : pchar;s : longint);
  219.  
  220.            { reads the file time stamp of the file, }
  221.            { the file must be opened                }
  222.            function getftime : longint;
  223.  
  224.            { returns filesize }
  225.            function getsize : longint;
  226.  
  227.            { returns the path }
  228.            function getpath : string;
  229.  
  230.            { resets the crc }
  231.            procedure clear_crc;
  232.  
  233.            { returns the crc }
  234.            function getcrc : longint;
  235.        end;
  236.  
  237.     { releases the string p and assignes nil to p }
  238.     { if p=nil then freemem isn't called          }
  239.     procedure stringdispose(var p : pstring);
  240.  
  241.     { allocates mem for a copy of s, copies s to this mem and returns }
  242.     { a pointer to this mem                                           }
  243.     function stringdup(const s : string) : pstring;
  244.  
  245.     { allocates memory for s and copies s as zero terminated string
  246.       to that mem and returns a pointer to that mem }
  247.     function strpnew(const s : string) : pchar;
  248.  
  249.     { makes a char lowercase, with spanish, french and german char set }
  250.     function lowercase(c : char) : char;
  251.  
  252.     { makes zero terminated string to a pascal string }
  253.     { the data in p is modified and p is returned     }
  254.     function pchar2pstring(p : pchar) : pstring;
  255.  
  256.     { ambivalent to pchar2pstring }
  257.     function pstring2pchar(p : pstring) : pchar;
  258.  
  259.   (***********************************************************************)
  260.   (* PROCEDURE Resetfile/RewriteFile - this creates the linked list of   *)
  261.   (*  opened files - only implemented in TBufferedFile currently.        *)
  262.   (***********************************************************************)
  263.     procedure ResetFile(var f:file);
  264.     procedure RewriteFile(var f:file);
  265.   (***************************************